home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / dired / dired-vms.el < prev    next >
Encoding:
Text File  |  1995-03-25  |  10.1 KB  |  279 lines
  1. ;; dired-vms.el - VMS support for dired. Revision: 1.17 
  2. ;; Copyright (C) 1990, 1992 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of XEmacs.
  5.  
  6. ;; XEmacs is free software; you can redistribute it and/or modify it
  7. ;; under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; XEmacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14. ;; General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  18. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ;; Id: dired-vms.el,v 1.17 1991/09/09 16:54:03 sk RelBeta 
  21.  
  22. ;; You'll need vmsproc.el for this function:
  23. (autoload 'subprocess-command-to-buffer "vmsproc")
  24.  
  25. (setq dired-subdir-regexp "^ *Directory \\([][:.A-Z-0-9_$;<>]+\\)\\(\\)[\n\r]")
  26.  
  27. (defconst dired-vms-filename-regexp
  28. "\\(\\([_A-Z0-9$]?\\|[_A-Z0-9$][_A-Z0-9$---]*\\)\\.[_A-Z0-9$---]*;+[0-9]*\\)"
  29.   "Regular expression to match for a valid VMS file name in Dired buffer.
  30. Stupid freaking bug! Position of _ and $ shouldn't matter but they do.
  31. Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX
  32. Other orders of $ and _ seem to all work just fine.")
  33.  
  34. (setq dired-re-mark "^[^ \n\t]")
  35.  
  36. (defvar dired-directory-command
  37.   "DIRECTORY/SIZE/DATE/PROT"
  38.   "Directory command for dired under VMS.")
  39.  
  40. ;; requires vmsproc.el to work
  41. (defun dired-ls (file switches &optional wildcard full-directory-p)
  42.   "Insert ls output of FILE,formatted according to SWITCHES.
  43. Optional third arg WILDCARD means treat FILE as shell wildcard.
  44. Optional fourth arg FULL-DIRECTORY-P means file is a directory and
  45. switches do not contain `d'.
  46.  
  47. SWITCHES default to dired-listing-switches.
  48.  
  49. This is the VMS version of this UNIX command.
  50. The SWITCHES and WILDCARD arguments are ignored.
  51. Uses dired-directory-command."
  52.   (save-restriction;; Must drag point along:
  53.     (narrow-to-region (point) (point))
  54.     (subprocess-command-to-buffer
  55.      (concat dired-directory-command " " file)
  56.      (current-buffer))
  57.     (if full-directory-p
  58.     (goto-char (point-max))
  59.       ;; Just the file line if no full directory required:
  60.       (goto-char (point-min))  
  61.       (let ((case-fold-search nil))
  62.     (re-search-forward dired-subdir-regexp)
  63.     (re-search-forward (concat "^" dired-vms-filename-regexp)))
  64.       (beginning-of-line)
  65.       (delete-region (point-min) (point))
  66.       (forward-line 1)
  67.       (delete-region (point) (point-max)))))
  68.  
  69. (defun dired-insert-headerline (dir)    ; redefinition
  70.   ;; VMS dired-ls makes its own headerline, but we must position the
  71.   ;; cursor where dired-insert-subdir expects it.
  72.   ;; This does not check whether the headerline matches DIR.
  73.   (re-search-forward dired-subdir-regexp)
  74.   (goto-char (match-end 1)))
  75.  
  76.  
  77. (defun dired-make-absolute (file &optional dir)
  78.   ;;"Convert FILE (a pathname relative to DIR) to an absolute pathname."
  79.   ;; This should be good enough for ange-ftp, but might easily be
  80.   ;; redefined (for VMS?).
  81.   ;; It should be reasonably fast, though, as it is called in
  82.   ;; dired-get-filename.
  83.   (concat (or dir
  84.           (dired-current-directory)
  85.           default-directory)
  86.       file))
  87.  
  88. (defun dired-make-relative (file &optional dir)
  89.   ;; In VMS we don't want relative names at all because of search path
  90.   ;; logical names.  Also, we never need to raise an error when a file
  91.   ;; `doesn't belong' in this buffer (like in the Unix case). 
  92.   file)
  93.  
  94. (defun dired-in-this-tree (file dir)
  95.   ;;"Is FILE part of the directory tree starting at DIR?"
  96.   ;; Under VMS, file="DEV:[foo.bar]zod", dir="DEV:[foo]"
  97.   (or (string= (substring dir -1) "\]")
  98.       (string= (substring dir -1) "\:")
  99.       (error "Not a directory: %s" dir))
  100.   (string-match (concat "^" (regexp-quote (substring dir 0 -1)))
  101.          file))
  102.  
  103. (defun dired-vms-split-filename (file)
  104.   (if (string-match;; "DEV:[DIR]FIL" \1=DEV \2=DIR \3=FIL
  105.        "^\\([.A-Z-0-9_$;]*\\):?[[<]\\([.A-Z-0-9_$;]*\\)[]>]\\([.A-Z-0-9_$;]*\\)$"
  106.        file)
  107.       (mapcar '(lambda (x)
  108.          (substring file (match-beginning x) (match-end x)))
  109.           '(1 2 3))))
  110.  
  111. ;; Must use this in dired-noselect instead of expand-file-name and
  112. ;; file-name-as-directory
  113. ;; Taken from the VMS dired version by
  114. ;;Roland Roberts                      BITNET: roberts@uornsrl
  115. ;;  Nuclear Structure Research Lab  INTERNET: rbr4@uhura.cc.rochester.edu
  116. ;;  271 East River Road                 UUCP: rochester!ur-cc!uhura!rbr4
  117. ;;  Rochester, NY  14267                AT&T: (716) 275-8962
  118.  
  119.  
  120. (defun dired-noselect (dirname &optional switches)
  121.   "Like M-x dired but returns the dired buffer as value, does not select it."
  122.   (setq dirname (dired-fix-directory dirname))
  123.   (dired-internal-noselect dirname switches))
  124.  
  125. (defun dired-fix-directory (dirname)
  126.   "Fix up dirname to be a valid directory name and return it"
  127.   (setq dirname
  128.     (expand-file-name (or dirname (setq dirname default-directory))))
  129.   (let ((end (1- (length dirname)))
  130.     bracket colon)
  131.     (if (or (char-equal ?\] (elt dirname end))
  132.         (char-equal ?\: (elt dirname end)))
  133.     dirname
  134.       (setq bracket (string-match "\\]" dirname))
  135.       (setq colon (string-match "\\:" dirname))
  136.       (setq end (string-match "\\.DIR" dirname (or bracket colon)))
  137.       (if end
  138.       (let ((newdir
  139.          (if bracket (concat (substring dirname 0 bracket)
  140.                      ".")
  141.            (if colon (concat (substring dirname 0 (1+ colon))
  142.                      "[")
  143.              "["))))
  144.         (concat newdir (substring dirname
  145.                       (1+ (or bracket colon)) end)
  146.             "]"))
  147.     (if bracket (substring dirname 0 (1+ bracket))
  148.       (if colon (substring dirname 0 (1+ colon))
  149.         default-directory))))))
  150.  
  151. ;; Versions are not yet supported in dired.el (as of version 4.53):
  152. ;;(setq dired-file-version-regexp "[.;][0-9]+$")
  153.  
  154. (defun dired-move-to-filename (&optional raise-error eol)
  155.   "In dired, move to first char of filename on this line.
  156. Returns position (point) or nil if no filename on this line."
  157.   ;; This is the VMS version.
  158.   (or eol (setq eol (progn (end-of-line) (point))))
  159.   (beginning-of-line)
  160.   (if (re-search-forward (concat " " dired-vms-filename-regexp) eol t)
  161.       (goto-char (match-beginning 1))
  162.     (if raise-error
  163.     (error "No file on this line")
  164.       nil)))
  165.  
  166. (defun dired-move-to-end-of-filename (&optional no-error eol)
  167.   ;; Assumes point is at beginning of filename,
  168.   ;; thus the rwx bit re-search-backward below will succeed in *this* line.
  169.   ;; So, it should be called only after (dired-move-to-filename t).
  170.   ;; case-fold-search must be nil, at least for VMS.
  171.   ;; On failure, signals an error or returns nil.
  172.   ;; This is the VMS version.
  173.   (let (opoint flag ex sym hidden case-fold-search)
  174.     (setq opoint (point))
  175.     (or eol (setq eol (save-excursion (end-of-line) (point))))
  176.     (setq hidden (and selective-display
  177.               (save-excursion (search-forward "\r" eol t))))
  178.     (if hidden
  179.     nil
  180.       (re-search-forward dired-vms-filename-regexp eol t))
  181.     (or no-error
  182.     (not (eq opoint (point)))
  183.     (error (if hidden
  184.            (substitute-command-keys
  185.             "File line is hidden, type \\[dired-hide-subdir] to unhide")
  186.          "No file on this line")))
  187.     (if (eq opoint (point))
  188.     nil
  189.       (point))))
  190.  
  191. (defun dired-tree-lessp (dir1 dir2)
  192.   (setq dir1 (substring (file-name-as-directory dir1) 0 -1)
  193.     dir2 (substring (file-name-as-directory dir2) 0 -1))
  194.   (let ((components-1 (dired-split "[:.]" dir1))
  195.     (components-2 (dired-split "[:.]" dir2)))
  196.     (while (and components-1
  197.         components-2
  198.         (equal (car components-1) (car components-2)))
  199.       (setq components-1 (cdr components-1)
  200.         components-2 (cdr components-2)))
  201.     (let ((c1 (car components-1))
  202.       (c2 (car components-2)))
  203.  
  204.       (cond ((and c1 c2)
  205.          (string-lessp c1 c2))
  206.         ((and (null c1) (null c2))
  207.          nil)            ; they are equal, not lessp
  208.         ((null c1)            ; c2 is a subdir of c1: c1<c2
  209.          t)
  210.         ((null c2)            ; c1 is a subdir of c2: c1>c2
  211.          nil)
  212.         (t (error "This can't happen"))))))
  213.  
  214. (defun dired-insert-subdir-validate (dirname)
  215.   (let ((alist dired-subdir-alist)
  216.     (found nil)
  217.     item)
  218.     (while (and alist (not found))
  219.       (setq item (car alist)
  220.         alist (cdr alist))
  221.       (setq found (dired-in-this-tree dirname (car item))))
  222.     (if (not found)
  223.     (error  "%s: directory not in this buffer" dirname))))
  224.  
  225. (defun dired-insert-subdir-newpos (new-dir)
  226.   ;; Find pos for new subdir, according to tree order.
  227.   (let ((alist (reverse dired-subdir-alist)) elt dir pos new-pos found)
  228.     (while alist
  229.       (setq elt (car alist)
  230.         alist (cdr alist)
  231.         dir (car elt)
  232.         pos (dired-get-subdir-min elt))
  233.       (if (or (and found
  234.            (or (dired-in-this-tree dir found)
  235.                (setq alist nil)))
  236.           (and (dired-in-this-tree new-dir dir)
  237.            (setq found dir)))
  238.       (if (dired-tree-lessp dir new-dir)
  239.           ;; Insert NEW-DIR after DIR
  240.           (setq new-pos (dired-get-subdir-max elt)))))
  241.     (goto-char new-pos))
  242.   ;; want a separating newline between subdirs
  243.   (or (eobp)
  244.       (forward-line -1))
  245.   (insert "\n")
  246.   (point))
  247.  
  248. (defun dired-between-files ()
  249.   (save-excursion
  250.     (beginning-of-line)
  251.     (or (equal (following-char) 9)
  252.     (progn (forward-char 2)
  253.            (or (looking-at "Total of")
  254.            (equal (following-char) 32))))))
  255.  
  256. (defun dired-buffers-for-dir (dir)
  257.   ;; Return a list of buffers that dired DIR (top level or in-situ subdir).
  258.   ;; The list is in reverse order of buffer creation, most recent last.
  259.   ;; As a side effect, killed dired buffers for DIR are removed from
  260.   ;; dired-buffers.
  261.   (setq dir (file-name-as-directory dir))
  262.   (let ((alist dired-buffers) result elt)
  263.     (while alist
  264.       (setq elt (car alist))
  265.       ;; In Unix we only looked into the buffer when
  266.       ;; (dired-in-this-tree dir (car elt)) returned non-nil.
  267.       ;; In VMS we have to look into each buffer because it doesn't
  268.       ;; necessarily contain only the tree starting at the top level directory
  269.       (let ((buf (cdr elt)))
  270.     (if (buffer-name buf)
  271.         (if (assoc dir (save-excursion
  272.                  (set-buffer buf)
  273.                  dired-subdir-alist))
  274.         (setq result (cons buf result)))
  275.       ;; else buffer is killed - clean up:
  276.       (setq dired-buffers (delq elt dired-buffers))))
  277.       (setq alist (cdr alist)))
  278.     result))
  279.